home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / lang / elisp / primitives / syntax.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  7.8 KB  |  267 lines
  1. (define-module (lang elisp primitives syntax)
  2.   #:use-module (lang elisp internals evaluation)
  3.   #:use-module (lang elisp internals fset)
  4.   #:use-module (lang elisp internals lambda)
  5.   #:use-module (lang elisp internals set)
  6.   #:use-module (lang elisp internals trace)
  7.   #:use-module (lang elisp transform))
  8.  
  9. ;;; Define Emacs Lisp special forms as macros.  This is more flexible
  10. ;;; than handling them specially in the translator: allows them to be
  11. ;;; redefined, and hopefully allows better source location tracking.
  12.  
  13. ;;; {Variables}
  14.  
  15. (define (setq exp env)
  16.   (cons begin
  17.     (let loop ((sets (cdr exp)))
  18.       (if (null? sets)
  19.           '()
  20.           (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets)))
  21.             (loop (cddr sets)))))))
  22.  
  23. (fset 'setq
  24.       (procedure->memoizing-macro setq))
  25.  
  26. (fset 'defvar
  27.       (procedure->memoizing-macro
  28.         (lambda (exp env)
  29.       (trc 'defvar (cadr exp))
  30.       (if (null? (cddr exp))
  31.           `(,quote ,(cadr exp))
  32.           `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
  33.                 ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
  34.                (,quote ,(cadr exp)))))))
  35.  
  36. (fset 'defconst
  37.       (procedure->memoizing-macro
  38.         (lambda (exp env)
  39.       (trc 'defconst (cadr exp))
  40.       `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
  41.            (,quote ,(cadr exp))))))
  42.  
  43. ;;; {lambda, function and macro definitions}
  44.  
  45. (fset 'lambda
  46.       (procedure->memoizing-macro
  47.        (lambda (exp env)
  48.      (transform-lambda/interactive exp '<elisp-lambda>))))
  49.  
  50. (fset 'defun
  51.       (procedure->memoizing-macro
  52.        (lambda (exp env)
  53.      (trc 'defun (cadr exp))
  54.      `(,begin (,fset (,quote ,(cadr exp))
  55.              ,(transform-lambda/interactive (cdr exp)
  56.                             (symbol-append '<elisp-defun:
  57.                                        (cadr exp)
  58.                                        '>)))
  59.           (,quote ,(cadr exp))))))
  60.  
  61. (fset 'interactive
  62.       (procedure->memoizing-macro
  63.         (lambda (exp env)
  64.       (fluid-set! interactive-spec exp)
  65.       #f)))
  66.  
  67. (fset 'defmacro
  68.       (procedure->memoizing-macro
  69.        (lambda (exp env)
  70.      (trc 'defmacro (cadr exp))
  71.      (call-with-values (lambda () (parse-formals (caddr exp)))
  72.        (lambda (required optional rest)
  73.          (let ((num-required (length required))
  74.            (num-optional (length optional)))
  75.            `(,begin (,fset (,quote ,(cadr exp))
  76.                    (,procedure->memoizing-macro
  77.                 (,lambda (exp1 env1)
  78.                   (,trc (,quote using) (,quote ,(cadr exp)))
  79.                   (,let* ((%--args (,cdr exp1))
  80.                       (%--num-args (,length %--args)))
  81.                     (,cond ((,< %--num-args ,num-required)
  82.                         (,error "Wrong number of args (not enough required args)"))
  83.                        ,@(if rest
  84.                          '()
  85.                          `(((,> %--num-args ,(+ num-required num-optional))
  86.                             (,error "Wrong number of args (too many args)"))))
  87.                        (else (,transformer
  88.                           (, @bind ,(append (map (lambda (i)
  89.                                        (list (list-ref required i)
  90.                                          `(,list-ref %--args ,i)))
  91.                                      (iota num-required))
  92.                                     (map (lambda (i)
  93.                                        (let ((i+nr (+ i num-required)))
  94.                                          (list (list-ref optional i)
  95.                                            `(,if (,> %--num-args ,i+nr)
  96.                                              (,list-ref %--args ,i+nr)
  97.                                              ,%nil))))
  98.                                      (iota num-optional))
  99.                                     (if rest
  100.                                     (list (list rest
  101.                                             `(,if (,> %--num-args
  102.                                                   ,(+ num-required
  103.                                                   num-optional))
  104.                                               (,list-tail %--args
  105.                                                       ,(+ num-required
  106.                                                       num-optional))
  107.                                               ,%nil)))
  108.                                     '()))
  109.                                ,@(map transformer (cdddr exp)))))))))))))))))
  110.  
  111. ;;; {Sequencing}
  112.  
  113. (fset 'progn
  114.       (procedure->memoizing-macro
  115.         (lambda (exp env)
  116.       `(,begin ,@(map transformer (cdr exp))))))
  117.  
  118. (fset 'prog1
  119.       (procedure->memoizing-macro
  120.         (lambda (exp env)
  121.       `(,let ((%--res1 ,(transformer (cadr exp))))
  122.          ,@(map transformer (cddr exp))
  123.          %--res1))))
  124.  
  125. (fset 'prog2
  126.       (procedure->memoizing-macro
  127.         (lambda (exp env)
  128.       `(,begin ,(transformer (cadr exp))
  129.            (,let ((%--res2 ,(transformer (caddr exp))))
  130.              ,@(map transformer (cdddr exp))
  131.              %--res2)))))
  132.  
  133. ;;; {Conditionals}
  134.  
  135. (fset 'if
  136.       (procedure->memoizing-macro
  137.         (lambda (exp env)
  138.       (let ((else-case (cdddr exp)))
  139.         (cond ((null? else-case)
  140.            `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
  141.           ((null? (cdr else-case))
  142.            `(,nil-cond ,(transformer (cadr exp))
  143.                    ,(transformer (caddr exp))
  144.                    ,(transformer (car else-case))))
  145.           (else
  146.            `(,nil-cond ,(transformer (cadr exp))
  147.                    ,(transformer (caddr exp))
  148.                    (,begin ,@(map transformer else-case)))))))))
  149.  
  150. (fset 'and
  151.       (procedure->memoizing-macro
  152.         (lambda (exp env)
  153.       (cond ((null? (cdr exp)) #t)
  154.         ((null? (cddr exp)) (transformer (cadr exp)))
  155.         (else
  156.          (cons nil-cond
  157.                (let loop ((args (cdr exp)))
  158.              (if (null? (cdr args))
  159.                  (list (transformer (car args)))
  160.                  (cons (list not (transformer (car args)))
  161.                    (cons %nil
  162.                      (loop (cdr args))))))))))))
  163.  
  164. ;;; NIL-COND expressions have the form:
  165. ;;;
  166. ;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
  167. ;;;
  168. ;;; The CONDs are evaluated in order until one of them returns true
  169. ;;; (in the Elisp sense, so not including empty lists).  If a COND
  170. ;;; returns true, its corresponding VAL is evaluated and returned,
  171. ;;; except if that VAL is the unspecified value, in which case the
  172. ;;; result of evaluating the COND is returned.  If none of the COND's
  173. ;;; returns true, ELSEVAL is evaluated and its value returned.
  174.  
  175. (define <-- *unspecified*)
  176.  
  177. (fset 'or
  178.       (procedure->memoizing-macro
  179.         (lambda (exp env)
  180.       (cond ((null? (cdr exp)) %nil)
  181.         ((null? (cddr exp)) (transformer (cadr exp)))
  182.         (else
  183.          (cons nil-cond
  184.                (let loop ((args (cdr exp)))
  185.              (if (null? (cdr args))
  186.                  (list (transformer (car args)))
  187.                  (cons (transformer (car args))
  188.                    (cons <--
  189.                      (loop (cdr args))))))))))))
  190.  
  191. (fset 'cond
  192.       (procedure->memoizing-macro
  193.        (lambda (exp env)
  194.      (if (null? (cdr exp))
  195.          %nil
  196.          (cons
  197.           nil-cond
  198.           (let loop ((clauses (cdr exp)))
  199.         (if (null? clauses)
  200.             (list %nil)
  201.             (let ((clause (car clauses)))
  202.               (if (eq? (car clause) #t)
  203.               (cond ((null? (cdr clause)) (list #t))
  204.                 ((null? (cddr clause))
  205.                  (list (transformer (cadr clause))))
  206.                 (else `((,begin ,@(map transformer (cdr clause))))))
  207.               (cons (transformer (car clause))
  208.                 (cons (cond ((null? (cdr clause)) <--)
  209.                         ((null? (cddr clause))
  210.                          (transformer (cadr clause)))
  211.                         (else
  212.                          `(,begin ,@(map transformer (cdr clause)))))
  213.                       (loop (cdr clauses)))))))))))))
  214.  
  215. (fset 'while
  216.       (procedure->memoizing-macro
  217.         (lambda (exp env)
  218.       `((,letrec ((%--while (,lambda ()
  219.                   (,nil-cond ,(transformer (cadr exp))
  220.                          (,begin ,@(map transformer (cddr exp))
  221.                              (%--while))
  222.                          ,%nil))))
  223.           %--while)))))
  224.  
  225. ;;; {Local binding}
  226.  
  227. (fset 'let
  228.       (procedure->memoizing-macro
  229.         (lambda (exp env)
  230.       `(, @bind ,(map (lambda (binding)
  231.                 (trc 'let binding)
  232.                 (if (pair? binding)
  233.                 `(,(car binding) ,(transformer (cadr binding)))
  234.                 `(,binding ,%nil)))
  235.               (cadr exp))
  236.             ,@(map transformer (cddr exp))))))
  237.  
  238. (fset 'let*
  239.       (procedure->memoizing-macro
  240.         (lambda (exp env)
  241.       (if (null? (cadr exp))
  242.           `(,begin ,@(map transformer (cddr exp)))
  243.           (car (let loop ((bindings (cadr exp)))
  244.              (if (null? bindings)
  245.              (map transformer (cddr exp))
  246.              `((, @bind (,(let ((binding (car bindings)))
  247.                     (if (pair? binding)
  248.                         `(,(car binding) ,(transformer (cadr binding)))
  249.                         `(,binding ,%nil))))
  250.                     ,@(loop (cdr bindings)))))))))))
  251.  
  252. ;;; {Exception handling}
  253.  
  254. (fset 'unwind-protect
  255.       (procedure->memoizing-macro
  256.         (lambda (exp env)
  257.       (trc 'unwind-protect (cadr exp))
  258.       `(,let ((%--throw-args #f))
  259.          (,catch #t
  260.            (,lambda ()
  261.          ,(transformer (cadr exp)))
  262.            (,lambda args
  263.          (,set! %--throw-args args)))
  264.          ,@(map transformer (cddr exp))
  265.          (,if %--throw-args
  266.           (,apply ,throw %--throw-args))))))
  267.